home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / src / fns.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-26  |  60.8 KB  |  2,433 lines
  1. /* Random utility Lisp functions.
  2.    Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc.
  3.    Copyright (C) 1994, 1995 Amdahl Corporation.
  4.  
  5. This file is part of XEmacs.
  6.  
  7. XEmacs is free software; you can redistribute it and/or modify it
  8. under the terms of the GNU General Public License as published by the
  9. Free Software Foundation; either version 2, or (at your option) any
  10. later version.
  11.  
  12. XEmacs is distributed in the hope that it will be useful, but WITHOUT
  13. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15. for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with XEmacs; see the file COPYING.  If not, write to the Free
  19. Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  20.  
  21. /* Synched up with: Mule 2.0, FSF 19.28. */
  22.  
  23. /* This file has been Mule-ized except as noted. */
  24.  
  25. /* Hacked on for Mule by Ben Wing, December 1994, January 1995. */
  26.  
  27. #include <config.h>
  28.  
  29. /* Note on some machines this defines `vector' as a typedef,
  30.    so make sure we don't use that name in this file.  */
  31. #undef vector
  32. #define vector *****
  33.  
  34. #include "lisp.h"
  35.  
  36. #include "bytecode.h"
  37. #include "buffer.h"
  38. #include "commands.h"
  39. #include "device.h"
  40. #include "events.h"
  41. #include "extents.h"
  42. #include "frame.h"
  43.  
  44. #include "systime.h"
  45.  
  46. Lisp_Object Qstring_lessp;
  47. Lisp_Object Qidentity;
  48.  
  49. DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
  50.   "Return the argument unchanged.")
  51.   (arg)
  52.      Lisp_Object arg;
  53. {
  54.   return arg;
  55. }
  56.  
  57. /* Let's assume that those systems that have random() also have it
  58.    prototyped.  If not, fix it in the appropriate s/ file. */
  59.  
  60. #ifndef HAVE_RANDOM
  61. /* Under linux with gcc -O, these are macros.  Do not declare. */
  62. #ifndef    random
  63. extern long random (void);
  64. #endif
  65. #ifndef srandom
  66. extern void srandom (int arg);
  67. #endif
  68. #endif /* HAVE_RANDOM */
  69.  
  70. DEFUN ("random", Frandom, Srandom, 0, 1, 0,
  71.   "Return a pseudo-random number.\n\
  72. On most systems all integers representable in Lisp are equally likely.\n\
  73. A lisp integer is a few bits smaller than a C `long'; on most systems,\n\
  74. this means 28 bits.)\n\
  75. With argument N, return random number in interval [0,N).\n\
  76. With argument t, set the random number seed from the current time and pid.")
  77.   (limit)
  78.      Lisp_Object limit;
  79. {
  80.   int val;
  81.  
  82.   if (EQ (limit, Qt))
  83.     srandom (getpid () + time (0));
  84.   if (INTP (limit) && XINT (limit) > 0)
  85.     {
  86.       if (XINT (limit) >= 0x40000000)
  87.     /* This case may occur on 64-bit machines.  */
  88.     val = random () % XINT (limit);
  89.       else
  90.     {
  91.       /* Try to take our random number from the higher bits of VAL,
  92.          not the lower, since (says Gentzel) the low bits of `random'
  93.          are less random than the higher ones.  We do this by using the
  94.          quotient rather than the remainder.  At the high end of the RNG
  95.          it's possible to get a quotient larger than limit; discarding
  96.          these values eliminates the bias that would otherwise appear
  97.          when using a large limit.  */
  98.       unsigned long denominator = (unsigned long)0x40000000 / XINT (limit);
  99.       do
  100.         val = (random () & 0x3fffffff) / denominator;
  101.       while (val >= XINT (limit));
  102.     }
  103.     }
  104.   else
  105.     val = random ();
  106.   return make_number (val);
  107. }
  108.  
  109. /* Random data-structure functions */
  110.  
  111. /* Charcount is a misnomer here as we might be dealing with the
  112.    length of a vector or list, but emphasizes that we're not dealing
  113.    with Bytecounts in strings */
  114. static Charcount
  115. length_with_bytecode_hack (Lisp_Object seq)
  116. {
  117.   if (!BYTECODEP (seq))
  118.     return (XINT (Flength (seq)));
  119.   else
  120.     {
  121.       struct Lisp_Bytecode *b = XBYTECODE (seq);
  122.       int intp = b->flags.interactivep;
  123.       int domainp = b->flags.domainp;
  124.       
  125.       if (intp)
  126.     return (COMPILED_INTERACTIVE + 1);
  127.       else if (domainp)
  128.     return (COMPILED_DOMAIN + 1);
  129.       else
  130.     return (COMPILED_DOC_STRING + 1);
  131.     }
  132. }
  133.  
  134. DEFUN ("length", Flength, Slength, 1, 1, 0,
  135.   "Return the length of vector, list or string SEQUENCE.")
  136.   (obj)
  137.      Lisp_Object obj;
  138. {
  139.   Lisp_Object tail;
  140.   int i;
  141.  
  142.  retry:
  143.   if (STRINGP (obj))
  144.     return (make_number (string_char_length (XSTRING (obj))));
  145.   else if (VECTORP (obj))
  146.     return (make_number (vector_length (XVECTOR (obj))));
  147.   else if (CONSP (obj))
  148.     {
  149.       for (i = 0, tail = obj; !NILP (tail); i++)
  150.     {
  151.       QUIT;
  152.       tail = Fcdr (tail);
  153.     }
  154.  
  155.       return (make_number (i));
  156.     }
  157.   else if (NILP (obj))
  158.     {
  159.       return (Qzero);
  160.     }
  161. #if 0 /* I don't see any need to make this "work" */
  162.   /* revolting "concat" callers use "length_with_bytecode_hack",
  163.    *  so that bytecomp.el (which uses "(append bytcode nil)"
  164.    *  "works". */
  165.   else if (COMPILED (obj))
  166.     ...
  167. #endif /* 0 */
  168.   else
  169.     {
  170.       obj = wrong_type_argument (Qsequencep, obj);
  171.       goto retry;
  172.     }
  173. }
  174.  
  175. /*** string functions. ***/
  176.  
  177. DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
  178.   "T if two strings have identical contents.\n\
  179. Case is significant.\n\
  180. Symbols are also allowed; their print names are used instead.")
  181.   (s1, s2)
  182.      Lisp_Object s1, s2;
  183. {
  184.   int len;
  185.  
  186.   if (SYMBOLP (s1))
  187.     XSETSTRING (s1, XSYMBOL (s1)->name);
  188.   if (SYMBOLP (s2))
  189.     XSETSTRING (s2, XSYMBOL (s2)->name);
  190.   CHECK_STRING (s1, 0);
  191.   CHECK_STRING (s2, 1);
  192.  
  193.   len = string_length (XSTRING (s1));
  194.   if (len != string_length (XSTRING (s2)) ||
  195.       memcmp (string_data (XSTRING (s1)), string_data (XSTRING (s2)), len))
  196.     return Qnil;
  197.   return Qt;
  198. }
  199.  
  200.  
  201. DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
  202.   "T if first arg string is less than second in lexicographic order.\n\
  203. If I18N2 support was compiled in, ordering is determined by the locale.\n\
  204. Case is significant for the default C locale.\n\
  205. Symbols are also allowed; their print names are used instead.")
  206.   (s1, s2)
  207.      Lisp_Object s1, s2;
  208. {
  209.   /* !!#### This function has not been Mule-ized. */
  210.   struct Lisp_String *p1, *p2;
  211.   Charcount end, len2;
  212.  
  213.   if (SYMBOLP (s1))
  214.     XSETSTRING (s1, XSYMBOL (s1)->name);
  215.   if (SYMBOLP (s2))
  216.     XSETSTRING (s2, XSYMBOL (s2)->name);
  217.   CHECK_STRING (s1, 0);
  218.   CHECK_STRING (s2, 1);
  219.  
  220.   p1 = XSTRING (s1);
  221.   p2 = XSTRING (s2);
  222.   end = string_char_length (XSTRING (s1));
  223.   len2 = string_char_length (XSTRING (s2));
  224.   if (end > len2)
  225.     end = len2;
  226.  
  227.   {
  228.     int i;
  229.  
  230. #ifdef I18N2
  231.     Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
  232.     /* Compare strings using collation order of locale. */
  233.     /* Need to be tricky to handle embedded nulls. */
  234.  
  235.     for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
  236.       {
  237.     int val = strcoll ((char *) string_data (p1) + i,
  238.                (char *) string_data (p2) + i);
  239.     if (val < 0)
  240.       return Qt;
  241.     if (val > 0)
  242.       return Qnil;
  243.       }
  244. #else /* not I18N2 */
  245.     for (i = 0; i < end; i++)
  246.       {
  247.         if (string_char (p1, i) != string_char (p2, i))
  248.           return string_char (p1, i) < string_char (p2, i) ? Qt : Qnil;
  249.       }
  250. #endif /* not I18N2 */
  251.     /* Can't do i < len2 because then comparison between "foo" and "foo^@"
  252.        won't work right in I18N2 case */
  253.     return ((end < len2) ? Qt : Qnil);
  254.   }
  255. }
  256.  
  257. DEFUN ("string-modified-tick", Fstring_modified_tick, Sstring_modified_tick,
  258.        1, 1, 0,
  259.   "Return STRING's tick counter, incremented for each change to the string.\n\
  260. Each string has a tick counter which is incremented each time the contents\n\
  261. of the string are changed (e.g. with `aset').  It wraps around occasionally.")
  262.   (string)
  263.   Lisp_Object string;
  264. {
  265.   struct Lisp_String *s;
  266.  
  267.   CHECK_STRING (string, 0);
  268.   s = XSTRING (string);
  269.   if (CONSP (s->plist) && INTP (XCAR (s->plist)))
  270.     return XCAR (s->plist);
  271.   else
  272.     return Qzero;
  273. }
  274.  
  275. void
  276. bump_string_modiff (Lisp_Object str)
  277. {
  278.   struct Lisp_String *s = XSTRING (str);
  279.  
  280. #ifdef I18N3
  281.   /* #### remove the `string-translatable' property from the string,
  282.      if there is one. */
  283. #endif
  284.   if (CONSP (s->plist) && INTP (XCAR (s->plist)))
  285.     XSETINT (XCAR (s->plist), 1+XINT (XCAR (s->plist)));
  286.   else
  287.     s->plist = Fcons (make_number (1), s->plist);
  288. }
  289.  
  290.  
  291. enum  concat_target_type { c_cons, c_string, c_vector };
  292. static Lisp_Object concat (int nargs, Lisp_Object *args,
  293.                            enum concat_target_type target_type,
  294.                            int last_special);
  295.  
  296. Lisp_Object
  297. concat2 (Lisp_Object s1, Lisp_Object s2)
  298. {
  299.   Lisp_Object args[2];
  300.   args[0] = s1;
  301.   args[1] = s2;
  302.   return concat (2, args, c_string, 0);
  303. }
  304.  
  305. Lisp_Object
  306. vconcat2 (Lisp_Object s1, Lisp_Object s2)
  307. {
  308.   Lisp_Object args[2];
  309.   args[0] = s1;
  310.   args[1] = s2;
  311.   return concat (2, args, c_vector, 0);
  312. }
  313.  
  314. DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
  315.   "Concatenate all the arguments and make the result a list.\n\
  316. The result is a list whose elements are the elements of all the arguments.\n\
  317. Each argument may be a list, vector or string.\n\
  318. The last argument is not copied, just used as the tail of the new list.")
  319.   (nargs, args)
  320.      int nargs;
  321.      Lisp_Object *args;
  322. {
  323.   return concat (nargs, args, c_cons, 1);
  324. }
  325.  
  326. DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
  327.   "Concatenate all the arguments and make the result a string.\n\
  328. The result is a string whose elements are the elements of all the arguments.\n\
  329. Each argument may be a string, a character (integer), a list of characters,\n\
  330. or a vector of numbers.")
  331.   (nargs, args)
  332.      int nargs;
  333.      Lisp_Object *args;
  334. {
  335.   return concat (nargs, args, c_string, 0);
  336. }
  337.  
  338. DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
  339.   "Concatenate all the arguments and make the result a vector.\n\
  340. The result is a vector whose elements are the elements of all the arguments.\n\
  341. Each argument may be a list, vector or string.")
  342.   (nargs, args)
  343.      int nargs;
  344.      Lisp_Object *args;
  345. {
  346.   return concat (nargs, args, c_vector, 0);
  347. }
  348.  
  349. DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
  350.   "Return a copy of a list, vector or string.\n\
  351. The elements of a list or vector are not copied; they are shared\n\
  352. with the original.")
  353.   (arg)
  354.      Lisp_Object arg;
  355. {
  356.  again:
  357.   if (NILP (arg)) return arg;
  358.   /* We handle conses separately because concat() is big and hairy and
  359.      doesn't handle (copy-sequence '(a b . c)) and it's easier to redo this
  360.      than to fix concat() without worrying about breaking other things.
  361.    */
  362.   if (CONSP (arg))
  363.     {
  364.       Lisp_Object rest = arg;
  365.       Lisp_Object head, tail;
  366.       tail = Qnil;
  367.       while (CONSP (rest))
  368.     {
  369.       Lisp_Object new = Fcons (XCAR (rest), XCDR (rest));
  370.       if (NILP (tail))
  371.         head = tail = new;
  372.       else
  373.         XCDR (tail) = new, tail = new;
  374.       rest = XCDR (rest);
  375.       QUIT;
  376.     }
  377.       if (!NILP (tail))
  378.     XCDR (tail) = rest;
  379.       return head;
  380.     }
  381.   else if (STRINGP (arg))
  382.     return concat (1, &arg, c_string, 0);
  383.   else if (VECTORP (arg))
  384.     return concat (1, &arg, c_vector, 0);
  385.   else
  386.     {
  387.       arg = wrong_type_argument (Qsequencep, arg);
  388.       goto again;
  389.     }
  390. }
  391.  
  392. static Lisp_Object
  393. concat (int nargs, Lisp_Object *args,
  394.         enum concat_target_type target_type,
  395.         int last_special)
  396. {
  397.   Lisp_Object val;
  398.   Lisp_Object tail = Qnil;
  399.   int toindex;
  400.   int argnum;
  401.   Lisp_Object last_tail;
  402.   Lisp_Object prev;
  403.   struct merge_replicas_struct *args_mr = 0;
  404.   struct gcpro gcpro1;
  405.  
  406.   /* The modus operandi in Emacs is "caller gc-protects args".
  407.      However, concat is called many times in Emacs on freshly
  408.      created stuff.  So we help those callers out by protecting
  409.      the args ourselves to save them a lot of temporary-variable
  410.      grief. */
  411.  
  412.   GCPRO1 (args[0]);
  413.   gcpro1.nvars = nargs;
  414.  
  415. #ifdef I18N3
  416.   /* #### if the result is a string and any of the strings have a string
  417.      for the `string-translatable' property, then concat should also
  418.      concat the args but use the `string-translatable' strings, and store
  419.      the result in the returned string's `string-translatable' property. */
  420. #endif
  421.   if (target_type == c_string)
  422.     {
  423.       int size = nargs * sizeof (struct merge_replicas_struct);
  424.       args_mr = (struct merge_replicas_struct *) alloca (size);
  425.     }
  426.  
  427.   /* In append, the last arg isn't treated like the others */
  428.   if (last_special && nargs > 0)
  429.     {
  430.       nargs--;
  431.       last_tail = args[nargs];
  432.     }
  433.   else
  434.     last_tail = Qnil;
  435.  
  436.   /* Check and coerce the arguments. */
  437.   for (argnum = 0; argnum < nargs; argnum++)
  438.     {
  439.       Lisp_Object seq = args[argnum];
  440.       if (CONSP (seq) || NILP (seq))
  441.         ;
  442.       else if (VECTORP (seq) || STRINGP (seq))
  443.         ;
  444.       else if (BYTECODEP (seq))
  445.         /* Urk!  We allow this, for "compatibility"... */
  446.         ;
  447.       else if (INTP (seq))
  448.         /* This is too revolting to think about but maintains
  449.            compatibility with FSF (and lots and lots of old code). */
  450.         args[argnum] = Fnumber_to_string (seq);
  451.       else
  452.         args[argnum] = wrong_type_argument (Qsequencep, seq);
  453.       
  454.       if (args_mr)
  455.         {
  456.           if (STRINGP (seq))
  457.             args_mr[argnum].dup_list = string_dups (XSTRING (seq));
  458.           else
  459.             args_mr[argnum].dup_list = Qnil;
  460.         }
  461.     }
  462.  
  463.   {
  464.     /* Charcount is a misnomer here as we might be dealing with the
  465.        length of a vector or list, but emphasizes that we're not dealing
  466.        with Bytecounts in strings */
  467.     Charcount total_length;
  468.  
  469.     for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
  470.       {
  471.         Charcount thislen = length_with_bytecode_hack (args[argnum]);
  472.         if (args_mr)
  473.       {
  474.         args_mr[argnum].entry_offset = total_length;
  475.         args_mr[argnum].entry_length = thislen;
  476.       }
  477.         total_length += thislen;
  478.       }
  479.  
  480.     switch (target_type)
  481.       {
  482.       case c_cons:
  483.         if (total_length == 0)
  484.           /* In append, if all but last arg are nil, return last arg */
  485.           RETURN_UNGCPRO (last_tail);
  486.         val = Fmake_list (make_number (total_length), Qnil);
  487.         break;
  488.       case c_vector:
  489.         val = make_vector (total_length, Qnil);
  490.         break;
  491.       case c_string:
  492.         val = Fmake_string (make_number (total_length), Qzero);
  493.         set_string_dups (XSTRING (val), merge_replicas (nargs, args_mr));
  494.         break;
  495.       default:
  496.         abort ();
  497.       }
  498.   }
  499.  
  500.  
  501.   if (CONSP (val))
  502.     tail = val, toindex = -1;    /* -1 in toindex is flag we are
  503.                     making a list */
  504.   else
  505.     toindex = 0;
  506.  
  507.   prev = Qnil;
  508.  
  509.   for (argnum = 0; argnum < nargs; argnum++)
  510.     {
  511.       Charcount thisleni = 0;
  512.       Charcount thisindex = 0;
  513.       Lisp_Object seq = args[argnum];
  514.  
  515.       if (!CONSP (seq))
  516.     {
  517.       thisleni = length_with_bytecode_hack (seq);
  518.     }
  519.  
  520.       while (1)
  521.     {
  522.       Lisp_Object elt;
  523.  
  524.       /* We've come to the end of this arg, so exit. */
  525.       if (NILP (seq))
  526.         break;
  527.  
  528.       /* Fetch next element of `seq' arg into `elt' */
  529.       if (CONSP (seq))
  530.             {
  531.               elt = Fcar (seq);
  532.               seq = Fcdr (seq);
  533.             }
  534.       else
  535.         {
  536.           if (thisindex >= thisleni)
  537.         break;
  538.  
  539.           if (STRINGP (seq))
  540.                 elt = make_number (string_char (XSTRING (seq), thisindex));
  541.           else if (VECTORP (seq))
  542.                 elt = vector_data (XVECTOR (seq))[thisindex];
  543.               else
  544.         elt = Felt (seq, make_number (thisindex));
  545.               thisindex++;
  546.         }
  547.  
  548.       /* Store into result */
  549.       if (toindex < 0)
  550.         {
  551.           /* toindex negative means we are making a list */
  552.           XCAR (tail) = elt;
  553.           prev = tail;
  554.           tail = XCDR (tail);
  555.         }
  556.       else if (VECTORP (val))
  557.         vector_data (XVECTOR (val))[toindex++] = elt;
  558.       else
  559.         {
  560.           while (!INTP (elt))
  561.         elt = wrong_type_argument (Qintegerp, elt);
  562.  
  563.           {
  564. #ifdef MASSC_REGISTER_BUG
  565.         you lose -- fix this code up!
  566.         /* Even removing all "register"s doesn't disable this bug!
  567.            Nothing simpler than this seems to work. */
  568.         unsigned char *p =
  569.           & string_char_address_of (XSTRING (val), toindex++);
  570.         *p = XINT (elt);
  571. #else
  572.         set_string_char (XSTRING (val), toindex++, XINT (elt));
  573. #endif
  574.           }
  575.         }
  576.     }
  577.     }
  578.   if (!NILP (prev))
  579.     XCDR (prev) = last_tail;
  580.  
  581.   RETURN_UNGCPRO (val);  
  582. }
  583.  
  584. DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
  585.   "Return a copy of ALIST.\n\
  586. This is an alist which represents the same mapping from objects to objects,\n\
  587. but does not share the alist structure with ALIST.\n\
  588. The objects mapped (cars and cdrs of elements of the alist)\n\
  589. are shared, however.\n\
  590. Elements of ALIST that are not conses are also shared.")
  591.   (alist)
  592.      Lisp_Object alist;
  593. {
  594.   Lisp_Object tem;
  595.  
  596.   CHECK_LIST (alist, 0);
  597.   if (NILP (alist))
  598.     return alist;
  599.   alist = concat (1, &alist, c_cons, 0);
  600.   for (tem = alist; CONSP (tem); tem = XCDR (tem))
  601.     {
  602.       Lisp_Object car;
  603.       car = XCAR (tem);
  604.  
  605.       if (CONSP (car))
  606.     XCAR (tem) = Fcons (XCAR (car), XCDR (car));
  607.     }
  608.   return alist;
  609. }
  610.  
  611. DEFUN ("copy-tree", Fcopy_tree, Scopy_tree, 1, 2, 0,
  612.   "Return a copy of a list and substructures.\n\
  613. The argument is copied, and any lists contained within it are copied\n\
  614. recursively.  Circularities and shared substructures are not preserved.\n\
  615. Second arg VECP causes vectors to be copied, too.  Strings are not copied.")
  616.    (arg, vecp)
  617.      Lisp_Object arg, vecp;
  618. {
  619.   if (CONSP (arg))
  620.     {
  621.       Lisp_Object rest;
  622.       rest = arg = Fcopy_sequence (arg);
  623.       while (CONSP (rest))
  624.     {
  625.       Lisp_Object elt = XCAR (rest);
  626.       QUIT;
  627.       if (CONSP (elt) || VECTORP (elt))
  628.         XCAR (rest) = Fcopy_tree (elt, vecp);
  629.       if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
  630.         XCDR (rest) = Fcopy_tree (XCDR (rest), vecp);
  631.       rest = XCDR (rest);
  632.     }
  633.     }
  634.   else if (VECTORP (arg) && ! NILP (vecp))
  635.     {
  636.       int i = vector_length (XVECTOR (arg));
  637.       int j;
  638.       arg = Fcopy_sequence (arg);
  639.       for (j = 0; j < i; j++)
  640.     {
  641.       Lisp_Object elt = vector_data (XVECTOR (arg)) [j];
  642.       QUIT;
  643.       if (CONSP (elt) || VECTORP (elt))
  644.         vector_data (XVECTOR (arg)) [j] = Fcopy_tree (elt, vecp);
  645.     }
  646.     }
  647.   return arg;
  648. }
  649.  
  650. Bytecount
  651. get_string_range (Lisp_Object string, Lisp_Object from, Lisp_Object to,
  652.           Bytecount *from_out, Bytecount *to_out)
  653. {
  654.   Charcount len;
  655.   Charcount from1, to1;
  656.  
  657.   CHECK_STRING (string, 0);
  658.   len = string_char_length (XSTRING (string));
  659.   if (NILP (from))
  660.     from1 = 0;
  661.   else
  662.     {
  663.       CHECK_INT (from, 1);
  664.       from1 = XINT (from);
  665.     }
  666.   if (NILP (to))
  667.     to1 = len;
  668.   else
  669.     {
  670.       CHECK_INT (to, 2);
  671.       to1 = XINT (to);
  672.     }
  673.  
  674.   if (from1 < 0)
  675.     from1 = from1 + len;
  676.   if (to1 < 0)
  677.     to1 = to1 + len;
  678.   if (!(0 <= from1 && from1 <= to1 && to1 <= len))
  679.     args_out_of_range_3 (string, make_number (from1), make_number (to1));
  680.  
  681.   *from_out = charcount_to_bytecount (string_data (XSTRING (string)), from1);
  682.   *to_out = charcount_to_bytecount (string_data (XSTRING (string)), to1);
  683.   return (*to_out - *from_out);
  684. }
  685.  
  686. Bytecount
  687. get_string_bytepos (Lisp_Object string, Lisp_Object pos)
  688. {
  689.   Charcount ccpos;
  690.  
  691.   CHECK_STRING (string, 0);
  692.   CHECK_INT (pos, 1);
  693.   ccpos = XINT (pos);
  694.   if (ccpos < 0 || ccpos > string_char_length (XSTRING (string)))
  695.     args_out_of_range (string, pos);
  696.   return charcount_to_bytecount (string_data (XSTRING (string)), ccpos);
  697. }
  698.  
  699. DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
  700.   "Return a substring of STRING, starting at index FROM and ending before TO.\n\
  701. TO may be nil or omitted; then the substring runs to the end of STRING.\n\
  702. If FROM or TO is negative, it counts from the end.\n\
  703. Relevant parts of the string-extent-data are copied in the new string.")
  704.   (string, from, to)
  705.      Lisp_Object string;
  706.      Lisp_Object from, to;
  707. {
  708.   Bytecount bfr, bto;
  709.   Bytecount len;
  710.   Lisp_Object val;
  711.  
  712.   /* Historically, FROM could not be omitted.  Whatever ... */
  713.   CHECK_INT (from, 1);
  714.   len = get_string_range (string, from, to, &bfr, &bto);
  715.   val = make_string (string_data (XSTRING (string)) + bfr, len);
  716.   /* Copy any applicable extent information into the new string: */
  717.   if (!NILP (string_dups (XSTRING (string))))
  718.     set_string_dups (XSTRING (val),
  719.              shift_replicas (string_dups (XSTRING (string)),
  720.                      - bfr, len));
  721.   return (val);
  722. }
  723.  
  724. DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
  725.   "Take cdr N times on LIST, returns the result.")
  726.   (n, list)
  727.      Lisp_Object n;
  728.      Lisp_Object list;
  729. {
  730.   REGISTER int i, num;
  731.   CHECK_INT (n, 0);
  732.   num = XINT (n);
  733.   for (i = 0; i < num && !NILP (list); i++)
  734.     {
  735.       QUIT;
  736.       list = Fcdr (list);
  737.     }
  738.   return list;
  739. }
  740.  
  741. DEFUN ("nth", Fnth, Snth, 2, 2, 0,
  742.   "Return the Nth element of LIST.\n\
  743. N counts from zero.  If LIST is not that long, nil is returned.")
  744.   (n, list)
  745.      Lisp_Object n, list;
  746. {
  747.   return Fcar (Fnthcdr (n, list));
  748. }
  749.  
  750. DEFUN ("elt", Felt, Selt, 2, 2, 0,
  751.   "Return element of SEQUENCE at index N.")
  752.   (seq, n)
  753.      Lisp_Object seq, n;
  754. {
  755.  retry:
  756.   CHECK_INT (n, 0);
  757.   if (CONSP (seq) || NILP (seq))
  758.     {
  759.       Lisp_Object tem = Fnthcdr (n, seq);
  760.       /* #### Utterly, completely, fucking disgusting.
  761.        * #### The whole point of "elt" is that it operates on
  762.        * #### sequences, and does error- (bounds-) checking.
  763.        */
  764.       if (CONSP (tem))
  765.     return (XCAR (tem));
  766.       else
  767. #if 1
  768.     /* This is The Way It Has Always Been. */
  769.     return Qnil;
  770. #else
  771.         /* This is The Way Mly Says It Should Be. */
  772.         args_out_of_range (seq, n);
  773. #endif
  774.     }
  775.   else if (STRINGP (seq)
  776.            || VECTORP (seq))
  777.     return (Faref (seq, n));
  778.   else if (BYTECODEP (seq))
  779.     {
  780.       int idx = XINT (n);
  781.       if (idx < 0)
  782.         {
  783.         lose:
  784.           args_out_of_range (seq, n);
  785.         }
  786.       /* Utter perversity */
  787.       {
  788.         struct Lisp_Bytecode *b = XBYTECODE (seq);
  789.         switch (idx)
  790.           {
  791.           case COMPILED_ARGLIST:
  792.             return (b->arglist);
  793.           case COMPILED_BYTECODE:
  794.             return (b->bytecodes);
  795.           case COMPILED_CONSTANTS:
  796.             return (b->constants);
  797.           case COMPILED_STACK_DEPTH:
  798.             return (make_number (b->maxdepth));
  799.           case COMPILED_DOC_STRING:
  800.         return (bytecode_documentation (b));
  801.           case COMPILED_DOMAIN:
  802.         return (bytecode_domain (b));
  803.           case COMPILED_INTERACTIVE:
  804.         if (b->flags.interactivep)
  805.           return (bytecode_interactive (b));
  806.         /* if we return nil, can't tell interactive with no args
  807.            from noninteractive. */
  808.         goto lose;
  809.           default:
  810.             goto lose;
  811.           }
  812.       }
  813.     }
  814.   else
  815.     {
  816.       seq = wrong_type_argument (Qsequencep, seq);
  817.       goto retry;
  818.     }
  819. }
  820.  
  821. DEFUN ("member", Fmember, Smember, 2, 2, 0,
  822.   "Return non-nil if ELT is an element of LIST.  Comparison done with `equal'.\n\
  823. The value is actually the tail of LIST whose car is ELT.")
  824.   (elt, list)
  825.      Lisp_Object elt;
  826.      Lisp_Object list;
  827. {
  828.   REGISTER Lisp_Object tail, tem;
  829.   for (tail = list; !NILP (tail); tail = Fcdr (tail))
  830.     {
  831.       tem = Fcar (tail);
  832.       if (! NILP (Fequal (elt, tem)))
  833.     return tail;
  834.       QUIT;
  835.     }
  836.   return Qnil;
  837. }
  838.  
  839. DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
  840.   "Return non-nil if ELT is an element of LIST.  Comparison done with EQ.\n\
  841. The value is actually the tail of LIST whose car is ELT.")
  842.   (elt, list)
  843.      Lisp_Object elt;
  844.      Lisp_Object list;
  845. {
  846.   REGISTER Lisp_Object tail, tem;
  847.   for (tail = list; !NILP (tail); tail = Fcdr (tail))
  848.     {
  849.       tem = Fcar (tail);
  850.       if (EQ (elt, tem)) return tail;
  851.       QUIT;
  852.     }
  853.   return Qnil;
  854. }
  855.  
  856. Lisp_Object
  857. memq_no_quit (Lisp_Object elt, Lisp_Object list)
  858. {
  859.   REGISTER Lisp_Object tail, tem;
  860.   for (tail = list; CONSP (tail); tail = XCDR (tail))
  861.     {
  862.       tem = XCAR (tail);
  863.       if (EQ (elt, tem)) return tail;
  864.     }
  865.   return Qnil;
  866. }
  867.  
  868. DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
  869.   "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
  870. The value is actually the element of LIST whose car is KEY.")
  871.   (key, list)
  872.      Lisp_Object key;
  873.      Lisp_Object list;
  874. {
  875.   REGISTER Lisp_Object tail, elt, tem;
  876.   for (tail = list; !NILP (tail); tail = Fcdr (tail))
  877.     {
  878.       elt = Fcar (tail);
  879.       if (!CONSP (elt)) continue;
  880.       tem = Fequal (Fcar (elt), key);
  881.       if (!NILP (tem)) return elt;
  882.       QUIT;
  883.     }
  884.   return Qnil;
  885. }
  886.  
  887. Lisp_Object
  888. assoc_no_quit (Lisp_Object key, Lisp_Object list)
  889. {
  890.   int speccount = specpdl_depth ();
  891.   specbind (Qinhibit_quit, Qt);
  892.   return (unbind_to (speccount, Fassoc (key, list)));
  893. }
  894.  
  895. DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
  896.   "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
  897. The value is actually the element of LIST whose car is KEY.\n\
  898. Elements of LIST that are not conses are ignored.")
  899.   (key, list)
  900.      Lisp_Object key;
  901.      Lisp_Object list;
  902. {
  903.   /* This function can GC. */
  904.   REGISTER Lisp_Object tail, elt, tem;
  905.   for (tail = list; !NILP (tail); tail = Fcdr (tail))
  906.     {
  907.       elt = Fcar (tail);
  908.       if (!CONSP (elt)) continue;
  909.       tem = Fcar (elt);
  910.       if (EQ (key, tem)) return elt;
  911.       QUIT;
  912.     }
  913.   return Qnil;
  914. }
  915.  
  916. /* Like Fassq but never report an error and do not allow quits.
  917.    Use only on lists known never to be circular.  */
  918.  
  919. Lisp_Object
  920. assq_no_quit (Lisp_Object key, Lisp_Object list)
  921. {
  922.   /* This cannot GC. */
  923.   REGISTER Lisp_Object tail, elt, tem;
  924.   for (tail = list; CONSP (tail); tail = XCDR (tail))
  925.     {
  926.       elt = XCAR (tail);
  927.       if (!CONSP (elt)) continue;
  928.       tem = XCAR (elt);
  929.       if (EQ (key, tem)) return elt;
  930.     }
  931.   return Qnil;
  932. }
  933.  
  934. DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
  935.   "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
  936. The value is actually the element of LIST whose cdr is KEY.")
  937.   (key, list)
  938.      Lisp_Object key;
  939.      Lisp_Object list;
  940. {
  941.   REGISTER Lisp_Object tail, elt, tem;
  942.   for (tail = list; !NILP (tail); tail = Fcdr (tail))
  943.     {
  944.       elt = Fcar (tail);
  945.       if (!CONSP (elt)) continue;
  946.       tem = Fequal (Fcdr (elt), key);
  947.       if (!NILP (tem)) return elt;
  948.       QUIT;
  949.     }
  950.   return Qnil;
  951. }
  952.  
  953. DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
  954.   "Return non-nil if KEY is `eq' to the cdr of an element of LIST.\n\
  955. The value is actually the element of LIST whose cdr is KEY.")
  956.   (key, list)
  957.      Lisp_Object key;
  958.      Lisp_Object list;
  959. {
  960.   REGISTER Lisp_Object tail, elt, tem;
  961.   for (tail = list; !NILP (tail); tail = Fcdr (tail))
  962.     {
  963.       elt = Fcar (tail);
  964.       if (!CONSP (elt)) continue;
  965.       tem = Fcdr (elt);
  966.       if (EQ (key, tem)) return elt;
  967.       QUIT;
  968.     }
  969.   return Qnil;
  970. }
  971.  
  972. Lisp_Object
  973. rassq_no_quit (Lisp_Object key, Lisp_Object list)
  974. {
  975.   REGISTER Lisp_Object tail, elt, tem;
  976.   for (tail = list; CONSP (tail); tail = XCDR (tail))
  977.     {
  978.       elt = XCAR (tail);
  979.       if (!CONSP (elt)) continue;
  980.       tem = XCDR (elt);
  981.       if (EQ (key, tem)) return elt;
  982.     }
  983.   return Qnil;
  984. }
  985.  
  986.  
  987. DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
  988.   "Delete by side effect any occurrences of ELT as a member of LIST.\n\
  989. The modified LIST is returned.  Comparison is done with `equal'.\n\
  990. If the first member of LIST is ELT, there is no way to remove it by side\n\
  991. effect; therefore, write `(setq foo (delete element foo))' to be sure\n\
  992. of changing the value of `foo'.")
  993.   (elt, list)
  994.      Lisp_Object elt;
  995.      Lisp_Object list;
  996. {
  997.   REGISTER Lisp_Object tail, prev;
  998.  
  999.   tail = list;
  1000.   prev = Qnil;
  1001.   while (!NILP (tail))
  1002.     {
  1003.       if (! NILP (Fequal (elt, Fcar (tail))))
  1004.     {
  1005.       if (NILP (prev))
  1006.         list = Fcdr (tail);
  1007.       else
  1008.         Fsetcdr (prev, Fcdr (tail));
  1009.     }
  1010.       else
  1011.     prev = tail;
  1012.       tail = Fcdr (tail);
  1013.       QUIT;
  1014.     }
  1015.   return list;
  1016. }
  1017.  
  1018. DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
  1019.   "Delete by side effect any occurrences of ELT as a member of LIST.\n\
  1020. The modified LIST is returned.  Comparison is done with `eq'.\n\
  1021. If the first member of LIST is ELT, there is no way to remove it by side\n\
  1022. effect; therefore, write `(setq foo (delq element foo))' to be sure of\n\
  1023. changing the value of `foo'.")
  1024.   (elt, list)
  1025.      Lisp_Object elt;
  1026.      Lisp_Object list;
  1027. {
  1028.   REGISTER Lisp_Object tail, prev;
  1029.   REGISTER Lisp_Object tem;
  1030.  
  1031.   tail = list;
  1032.   prev = Qnil;
  1033.   while (!NILP (tail))
  1034.     {
  1035.       tem = Fcar (tail);
  1036.       if (EQ (elt, tem))
  1037.     {
  1038.       if (NILP (prev))
  1039.         list = Fcdr (tail);
  1040.       else
  1041.         Fsetcdr (prev, Fcdr (tail));
  1042.     }
  1043.       else
  1044.     prev = tail;
  1045.       tail = Fcdr (tail);
  1046.       QUIT;
  1047.     }
  1048.   return list;
  1049. }
  1050.  
  1051. /* no quit, no errors; be careful */
  1052.  
  1053. Lisp_Object
  1054. delq_no_quit (Lisp_Object elt, Lisp_Object list)
  1055. {
  1056.   REGISTER Lisp_Object tail, prev;
  1057.   REGISTER Lisp_Object tem;
  1058.  
  1059.   tail = list;
  1060.   prev = Qnil;
  1061.   while (CONSP (tail))
  1062.     {
  1063.       tem = XCAR (tail);
  1064.       if (EQ (elt, tem))
  1065.     {
  1066.       if (NILP (prev))
  1067.         list = XCDR (tail);
  1068.       else
  1069.         XCDR (prev) = XCDR (tail);
  1070.     }
  1071.       else
  1072.     prev = tail;
  1073.       tail = XCDR (tail);
  1074.     }
  1075.   return list;
  1076. }
  1077.  
  1078. DEFUN ("remassoc", Fremassoc, Sremassoc, 2, 2, 0,
  1079.   "Delete by side effect any elements of LIST whose car is `equal' to KEY.\n\
  1080. The modified LIST is returned.  If the first member of LIST has a car\n\
  1081. that is `equal' to KEY, there is no way to remove it by side effect;\n\
  1082. therefore, write `(setq foo (remassoc key foo))' to be sure of changing\n\
  1083. the value of `foo'.")
  1084.   (key, list)
  1085.      Lisp_Object key;
  1086.      Lisp_Object list;
  1087. {
  1088.   REGISTER Lisp_Object tail, prev;
  1089.  
  1090.   tail = list;
  1091.   prev = Qnil;
  1092.   while (!NILP (tail))
  1093.     {
  1094.       Lisp_Object elt = Fcar (tail);
  1095.       if (CONSP (elt) && ! NILP (Fequal (key, Fcar (elt))))
  1096.     {
  1097.       if (NILP (prev))
  1098.         list = Fcdr (tail);
  1099.       else
  1100.         Fsetcdr (prev, Fcdr (tail));
  1101.     }
  1102.       else
  1103.     prev = tail;
  1104.       tail = Fcdr (tail);
  1105.       QUIT;
  1106.     }
  1107.   return list;
  1108. }
  1109.  
  1110. Lisp_Object
  1111. remassoc_no_quit (Lisp_Object key, Lisp_Object list)
  1112. {
  1113.   int speccount = specpdl_depth ();
  1114.   specbind (Qinhibit_quit, Qt);
  1115.   return (unbind_to (speccount, Fremassoc (key, list)));
  1116. }
  1117.  
  1118. DEFUN ("remassq", Fremassq, Sremassq, 2, 2, 0,
  1119.   "Delete by side effect any elements of LIST whose car is `eq' to KEY.\n\
  1120. The modified LIST is returned.  If the first member of LIST has a car\n\
  1121. that is `eq' to KEY, there is no way to remove it by side effect;\n\
  1122. therefore, write `(setq foo (remassq key foo))' to be sure of changing\n\
  1123. the value of `foo'.")
  1124.   (key, list)
  1125.      Lisp_Object key;
  1126.      Lisp_Object list;
  1127. {
  1128.   REGISTER Lisp_Object tail, prev;
  1129.  
  1130.   tail = list;
  1131.   prev = Qnil;
  1132.   while (!NILP (tail))
  1133.     {
  1134.       Lisp_Object elt = Fcar (tail);
  1135.       if (CONSP (elt) && EQ (key, Fcar (elt)))
  1136.     {
  1137.       if (NILP (prev))
  1138.         list = Fcdr (tail);
  1139.       else
  1140.         Fsetcdr (prev, Fcdr (tail));
  1141.     }
  1142.       else
  1143.     prev = tail;
  1144.       tail = Fcdr (tail);
  1145.       QUIT;
  1146.     }
  1147.   return list;
  1148. }
  1149.  
  1150. /* no quit, no errors; be careful */
  1151.  
  1152. Lisp_Object
  1153. remassq_no_quit (Lisp_Object key, Lisp_Object list)
  1154. {
  1155.   REGISTER Lisp_Object tail, prev;
  1156.   REGISTER Lisp_Object tem;
  1157.  
  1158.   tail = list;
  1159.   prev = Qnil;
  1160.   while (CONSP (tail))
  1161.     {
  1162.       tem = XCAR (tail);
  1163.       if (CONSP (tem) && EQ (key, XCAR (tem)))
  1164.     {
  1165.       if (NILP (prev))
  1166.         list = XCDR (tail);
  1167.       else
  1168.         XCDR (prev) = XCDR (tail);
  1169.     }
  1170.       else
  1171.     prev = tail;
  1172.       tail = XCDR (tail);
  1173.     }
  1174.   return list;
  1175. }
  1176.  
  1177. DEFUN ("remrassoc", Fremrassoc, Sremrassoc, 2, 2, 0,
  1178.   "Delete by side effect any elements of LIST whose cdr is `equal' to KEY.\n\
  1179. The modified LIST is returned.  If the first member of LIST has a car\n\
  1180. that is `equal' to KEY, there is no way to remove it by side effect;\n\
  1181. therefore, write `(setq foo (remrassoc key foo))' to be sure of changing\n\
  1182. the value of `foo'.")
  1183.   (key, list)
  1184.      Lisp_Object key;
  1185.      Lisp_Object list;
  1186. {
  1187.   REGISTER Lisp_Object tail, prev;
  1188.  
  1189.   tail = list;
  1190.   prev = Qnil;
  1191.   while (!NILP (tail))
  1192.     {
  1193.       Lisp_Object elt = Fcar (tail);
  1194.       if (CONSP (elt) && ! NILP (Fequal (key, Fcdr (elt))))
  1195.     {
  1196.       if (NILP (prev))
  1197.         list = Fcdr (tail);
  1198.       else
  1199.         Fsetcdr (prev, Fcdr (tail));
  1200.     }
  1201.       else
  1202.     prev = tail;
  1203.       tail = Fcdr (tail);
  1204.       QUIT;
  1205.     }
  1206.   return list;
  1207. }
  1208.  
  1209. DEFUN ("remrassq", Fremrassq, Sremrassq, 2, 2, 0,
  1210.   "Delete by side effect any elements of LIST whose cdr is `eq' to KEY.\n\
  1211. The modified LIST is returned.  If the first member of LIST has a car\n\
  1212. that is `eq' to KEY, there is no way to remove it by side effect;\n\
  1213. therefore, write `(setq foo (remrassq key foo))' to be sure of changing\n\
  1214. the value of `foo'.")
  1215.   (key, list)
  1216.      Lisp_Object key;
  1217.      Lisp_Object list;
  1218. {
  1219.   REGISTER Lisp_Object tail, prev;
  1220.  
  1221.   tail = list;
  1222.   prev = Qnil;
  1223.   while (!NILP (tail))
  1224.     {
  1225.       Lisp_Object elt = Fcar (tail);
  1226.       if (CONSP (elt) && EQ (key, Fcdr (elt)))
  1227.     {
  1228.       if (NILP (prev))
  1229.         list = Fcdr (tail);
  1230.       else
  1231.         Fsetcdr (prev, Fcdr (tail));
  1232.     }
  1233.       else
  1234.     prev = tail;
  1235.       tail = Fcdr (tail);
  1236.       QUIT;
  1237.     }
  1238.   return list;
  1239. }
  1240.  
  1241. /* no quit, no errors; be careful */
  1242.  
  1243. Lisp_Object
  1244. remrassq_no_quit (Lisp_Object key, Lisp_Object list)
  1245. {
  1246.   REGISTER Lisp_Object tail, prev;
  1247.   REGISTER Lisp_Object tem;
  1248.  
  1249.   tail = list;
  1250.   prev = Qnil;
  1251.   while (CONSP (tail))
  1252.     {
  1253.       tem = XCAR (tail);
  1254.       if (CONSP (tem) && EQ (key, XCDR (tem)))
  1255.     {
  1256.       if (NILP (prev))
  1257.         list = XCDR (tail);
  1258.       else
  1259.         XCDR (prev) = XCDR (tail);
  1260.     }
  1261.       else
  1262.     prev = tail;
  1263.       tail = XCDR (tail);
  1264.     }
  1265.   return list;
  1266. }
  1267.  
  1268. DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
  1269.   "Reverse LIST by modifying cdr pointers.\n\
  1270. Returns the beginning of the reversed list.")
  1271.   (list)
  1272.      Lisp_Object list;
  1273. {
  1274.   REGISTER Lisp_Object prev, tail, next;
  1275.  
  1276.   prev = Qnil;
  1277.   tail = list;
  1278.   while (!NILP (tail))
  1279.     {
  1280.       QUIT;
  1281.       next = Fcdr (tail);
  1282.       Fsetcdr (tail, prev);
  1283.       prev = tail;
  1284.       tail = next;
  1285.     }
  1286.   return prev;
  1287. }
  1288.  
  1289. DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
  1290.   "Reverse LIST, copying.  Returns the beginning of the reversed list.\n\
  1291. See also the function `nreverse', which is used more often.")
  1292.   (list)
  1293.      Lisp_Object list;
  1294. {
  1295.   Lisp_Object length;
  1296.   Lisp_Object *vec;
  1297.   Lisp_Object tail;
  1298.   REGISTER int i;
  1299.  
  1300.   length = Flength (list);
  1301.   vec = (Lisp_Object *) alloca (XINT (length) * sizeof (Lisp_Object));
  1302.   for (i = XINT (length) - 1, tail = list; i >= 0; i--, tail = Fcdr (tail))
  1303.     vec[i] = Fcar (tail);
  1304.  
  1305.   return Flist (XINT (length), vec);
  1306. }
  1307.  
  1308. static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2, 
  1309.                                Lisp_Object lisp_arg, 
  1310.                                int (*pred_fn) (Lisp_Object, Lisp_Object,
  1311.                                                Lisp_Object lisp_arg));
  1312.  
  1313. Lisp_Object
  1314. list_sort (Lisp_Object list,
  1315.            Lisp_Object lisp_arg, 
  1316.            int (*pred_fn) (Lisp_Object, Lisp_Object,
  1317.                            Lisp_Object lisp_arg))
  1318. {
  1319.   Lisp_Object front, back;
  1320.   Lisp_Object len, tem;
  1321.   struct gcpro gcpro1, gcpro2, gcpro3;
  1322.   int length;
  1323.  
  1324.   front = list;
  1325.   len = Flength (list);
  1326.   length = XINT (len);
  1327.   if (length < 2)
  1328.     return list;
  1329.  
  1330.   XSETINT (len, (length / 2) - 1);
  1331.   tem = Fnthcdr (len, list);
  1332.   back = Fcdr (tem);
  1333.   Fsetcdr (tem, Qnil);
  1334.  
  1335.   GCPRO3 (front, back, lisp_arg);
  1336.   front = list_sort (front, lisp_arg, pred_fn);
  1337.   back = list_sort (back, lisp_arg, pred_fn);
  1338.   UNGCPRO;
  1339.   return list_merge (front, back, lisp_arg, pred_fn);
  1340. }
  1341.  
  1342. void
  1343. run_hook_with_args (Lisp_Object hook_var, int nargs, ...)
  1344. {
  1345.   /* This function can GC */
  1346.   Lisp_Object rest;
  1347.   int i;
  1348.   va_list vargs;
  1349.   va_start (vargs, nargs);
  1350.  
  1351.   if (NILP (Fboundp (hook_var)))
  1352.     rest = Qnil;
  1353.   else
  1354.     rest = Fsymbol_value (hook_var);
  1355.   if (NILP (rest))
  1356.     {
  1357.       /* Discard C's excuse for &rest */
  1358.       for (i = 0; i < nargs; i++)
  1359.         (void) va_arg (vargs, Lisp_Object);
  1360.       va_end (vargs);
  1361.       return;
  1362.     }
  1363.   else
  1364.     {
  1365.       struct gcpro gcpro1, gcpro2;
  1366.       Lisp_Object *funcall_args =
  1367.     (Lisp_Object *) alloca ((1 + nargs) * sizeof (Lisp_Object));
  1368.  
  1369.       for (i = 0; i < nargs; i++)
  1370.         funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
  1371.       va_end (vargs);
  1372.  
  1373.       funcall_args[0] = rest;
  1374.       GCPRO2 (rest, *funcall_args);
  1375.       gcpro2.nvars = nargs + 1;
  1376.  
  1377.       if (!CONSP (rest) || EQ (Qlambda, XCAR (rest)))
  1378.         Ffuncall (nargs + 1, funcall_args);
  1379.       else
  1380.         {
  1381.           while (!NILP (rest))
  1382.             {
  1383.               funcall_args[0] = Fcar (rest);
  1384.               Ffuncall (nargs + 1, funcall_args);
  1385.               rest = Fcdr (rest);
  1386.             }
  1387.         }
  1388.       UNGCPRO;
  1389.     }
  1390. }
  1391.  
  1392.  
  1393.  
  1394. static int
  1395. merge_pred_function (Lisp_Object obj1, Lisp_Object obj2, 
  1396.                      Lisp_Object pred)
  1397. {
  1398.   Lisp_Object tmp;
  1399.  
  1400.   /* prevents the GC from happening in call2 */
  1401.   int speccount = specpdl_depth ();
  1402. /* Emacs' GC doesn't actually relocate pointers, so this probably
  1403.    isn't strictly necessary */
  1404.   record_unwind_protect (restore_gc_inhibit,
  1405.                          make_number (gc_currently_forbidden));
  1406.   gc_currently_forbidden = 1;
  1407.   tmp = call2 (pred, obj1, obj2);
  1408.   unbind_to (speccount, Qnil);
  1409.  
  1410.   if (NILP (tmp)) 
  1411.     return -1;
  1412.   else
  1413.     return 1;
  1414. }
  1415.  
  1416. DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
  1417.   "Sort LIST, stably, comparing elements using PREDICATE.\n\
  1418. Returns the sorted list.  LIST is modified by side effects.\n\
  1419. PREDICATE is called with two elements of LIST, and should return T\n\
  1420. if the first element is \"less\" than the second.")
  1421.   (list, pred)
  1422.      Lisp_Object list, pred;
  1423. {
  1424.   return list_sort (list, pred, merge_pred_function);
  1425. }
  1426.  
  1427. Lisp_Object
  1428. merge (Lisp_Object org_l1, Lisp_Object org_l2, 
  1429.        Lisp_Object pred)
  1430. {
  1431.   return list_merge (org_l1, org_l2, pred, merge_pred_function);
  1432. }
  1433.  
  1434.  
  1435. static Lisp_Object
  1436. list_merge (Lisp_Object org_l1, Lisp_Object org_l2, 
  1437.             Lisp_Object lisp_arg, 
  1438.             int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
  1439. {
  1440.   Lisp_Object value;
  1441.   Lisp_Object tail;
  1442.   Lisp_Object tem;
  1443.   Lisp_Object l1, l2;
  1444.   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
  1445.  
  1446.   l1 = org_l1;
  1447.   l2 = org_l2;
  1448.   tail = Qnil;
  1449.   value = Qnil;
  1450.  
  1451.   /* It is sufficient to protect org_l1 and org_l2.
  1452.      When l1 and l2 are updated, we copy the new values
  1453.      back into the org_ vars.  */
  1454.   
  1455.   GCPRO4 (org_l1, org_l2, lisp_arg, value);
  1456.  
  1457.   while (1)
  1458.     {
  1459.       if (NILP (l1))
  1460.     {
  1461.       UNGCPRO;
  1462.       if (NILP (tail))
  1463.         return l2;
  1464.       Fsetcdr (tail, l2);
  1465.       return value;
  1466.     }
  1467.       if (NILP (l2))
  1468.     {
  1469.       UNGCPRO;
  1470.       if (NILP (tail))
  1471.         return l1;
  1472.       Fsetcdr (tail, l1);
  1473.       return value;
  1474.     }
  1475.  
  1476.       if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0)
  1477.     {
  1478.       tem = l1;
  1479.       l1 = Fcdr (l1);
  1480.       org_l1 = l1;
  1481.     }
  1482.       else
  1483.     {
  1484.       tem = l2;
  1485.       l2 = Fcdr (l2);
  1486.       org_l2 = l2;
  1487.     }
  1488.       if (NILP (tail))
  1489.     value = tem;
  1490.       else
  1491.     Fsetcdr (tail, tem);
  1492.       tail = tem;
  1493.     }
  1494. }
  1495.  
  1496.  
  1497. /************************************************************************/
  1498. /*                  property-list functions                */
  1499. /************************************************************************/
  1500.  
  1501. static void
  1502. check_plist_structure (Lisp_Object plist)
  1503. {
  1504.   Lisp_Object rest;
  1505.  
  1506.   for (rest = plist; !NILP (rest); rest = XCDR (XCDR (rest)))
  1507.     {
  1508.       QUIT; /* in case of circularities */
  1509.       if (!CONSP (rest) || !SYMBOLP (XCAR (rest)) || !CONSP (XCDR (rest)))
  1510.     error ("Invalid property list structure");
  1511.     }
  1512. }
  1513.  
  1514. /* For properties of text, we need to do order-insensitive comparison of
  1515.    plists.  That is, we need to compare two plists such that they are the
  1516.    same if they have the same set of keys with non-nil values, and equivalent
  1517.    values.  So (a 1 b 2 c nil) would be equal to (b 2 a 1).
  1518.  */
  1519. int 
  1520. plists_differ (Lisp_Object a, Lisp_Object b, int depth)
  1521. {
  1522.   int eqp = (depth == -1);    /* -1 as depth means us eq, not equal. */
  1523.   int la, lb, m, i, fill;
  1524.   Lisp_Object *keys, *vals;
  1525.   char *flags;
  1526.   Lisp_Object rest;
  1527.  
  1528.   if (NILP (a) && NILP (b))
  1529.     return 0;
  1530.  
  1531.   la = XINT (Flength (a));
  1532.   lb = XINT (Flength (b));
  1533.   m = (la > lb ? la : lb);
  1534.   fill = 0;
  1535.   keys = (Lisp_Object *) alloca (m * sizeof (Lisp_Object));
  1536.   vals = (Lisp_Object *) alloca (m * sizeof (Lisp_Object));
  1537.   flags = (char *) alloca (m * sizeof (char));
  1538.  
  1539.   /* First extract the pairs from A whose value is not nil. */
  1540.   for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
  1541.     {
  1542.       Lisp_Object k = XCAR (rest);
  1543.       Lisp_Object v = XCAR (XCDR (rest));
  1544.       if (NILP (v)) continue;
  1545.       keys [fill] = k;
  1546.       vals [fill] = v;
  1547.       flags[fill] = 0;
  1548.       fill++;
  1549.     }
  1550.   /* Now iterate over B, and stop if we find something that's not in A,
  1551.      or that doesn't match.  As we match, mark them. */
  1552.   for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest)))
  1553.     {
  1554.       Lisp_Object k = XCAR (rest);
  1555.       Lisp_Object v = XCAR (XCDR (rest));
  1556.       if (NILP (v)) continue;
  1557.       for (i = 0; i < fill; i++)
  1558.     {
  1559.       if (EQ (k, keys [i]))
  1560.         {
  1561.           if ((eqp
  1562.            ? !EQ (v, vals [i])
  1563.            : !internal_equal (v, vals [i], depth)))
  1564.         /* a property in B has a different value than in A */
  1565.         goto MISMATCH;
  1566.           flags [i] = 1;
  1567.           break;
  1568.         }
  1569.     }
  1570.       if (i == fill)
  1571.     /* there are some properties in B that are not in A */
  1572.     goto MISMATCH;
  1573.     }
  1574.   /* Now check to see that all the properties in A were also in B */
  1575.   for (i = 0; i < fill; i++)
  1576.     if (flags [i] == 0)
  1577.       goto MISMATCH;
  1578.  
  1579.   /* Ok. */
  1580.   return 0;
  1581.  
  1582.  MISMATCH:
  1583.   return 1;
  1584. }
  1585.  
  1586. DEFUN ("plists-eq", Fplists_eq, Splists_eq, 2, 2, 0,
  1587.   "Return non-nil if property lists A and B are `eq'.\n\
  1588. A property list is an alternating list of keywords and values, where a nil\n\
  1589.  value is equivalent to the property not existing.  This function does\n\
  1590.  order-insensitive comparisons of the property lists: For example, the\n\
  1591.  property lists '(a 1 b 2 c nil) and '(b 2 a 1) are equal.\n\
  1592. Comparison between values is done using `eq'.  See also `plists-equal'.")
  1593.   (a, b)
  1594.      Lisp_Object a, b;
  1595. {
  1596.   check_plist_structure (a);
  1597.   check_plist_structure (b);
  1598.   return (plists_differ (a, b, -1) ? Qnil : Qt);
  1599. }
  1600.  
  1601. DEFUN ("plists-equal", Fplists_equal, Splists_equal, 2, 2, 0,
  1602.   "Return non-nil if property lists A and B are `equal'.\n\
  1603. A property list is an alternating list of keywords and values, where a nil\n\
  1604.  value is equivalent to the property not existing.  This function does\n\
  1605.  order-insensitive comparisons of the property lists: For example, the\n\
  1606.  property lists '(a 1 b 2 c nil) and '(b 2 a 1) are equal.\n\
  1607. Comparison between values is done using `equal'.  See also `plists-eq'.")
  1608.   (a, b)
  1609.      Lisp_Object a, b;
  1610. {
  1611.   check_plist_structure (a);
  1612.   check_plist_structure (b);
  1613.   return (plists_differ (a, b, 1) ? Qnil : Qt);
  1614. }
  1615.  
  1616. /* Return the value associated with key PROPERTY in property list PLIST.
  1617.    Return nil if key not found.  This function is used for internal
  1618.    property lists that cannot be directly manipulated by the user.
  1619.    Perhaps we should merge this function with Fgetf ().
  1620.    */
  1621. int
  1622. internal_getf (Lisp_Object plist, Lisp_Object property,
  1623.            Lisp_Object *value_out)
  1624. {
  1625.   Lisp_Object tail = plist;
  1626.  
  1627.   for (; !NILP (tail); tail = XCDR (XCDR (tail)))
  1628.     {
  1629.       struct Lisp_Cons *c = XCONS (tail);
  1630.       if (EQ (c->car, property))
  1631.     {
  1632.       *value_out = XCAR (c->cdr);
  1633.       return 1;
  1634.     }
  1635.  
  1636.     }
  1637.  
  1638.   return 0;
  1639. }
  1640.  
  1641. /* Set PLIST's value for PROPERTY to VALUE.  Analogous to internal_getf(). */
  1642.  
  1643. void
  1644. internal_putf (Lisp_Object *plist, Lisp_Object property, Lisp_Object value)
  1645. {
  1646.   Lisp_Object tail = *plist;
  1647.   
  1648.   for (; !NILP (tail); tail = XCDR (XCDR (tail)))
  1649.     {
  1650.       struct Lisp_Cons *c = XCONS (tail);
  1651.       if (EQ (c->car, property))
  1652.     {
  1653.       XCAR (c->cdr) = value;
  1654.       return;
  1655.     }
  1656.     }
  1657.  
  1658.   *plist = Fcons (property, Fcons (value, *plist));
  1659. }
  1660.  
  1661. int
  1662. internal_remprop (Lisp_Object *plist, Lisp_Object property)
  1663. {
  1664.   Lisp_Object tail = *plist;
  1665.  
  1666.   if (NILP (tail))
  1667.     return 0;
  1668.  
  1669.   if (EQ (XCAR (tail), property))
  1670.     {
  1671.       *plist = XCDR (XCDR (tail));
  1672.       return 1;
  1673.     }
  1674.  
  1675.   for (tail = XCDR (tail); !NILP (XCDR (tail));
  1676.        tail = XCDR (XCDR (tail)))
  1677.     {
  1678.       struct Lisp_Cons *c = XCONS (tail);
  1679.       if (EQ (XCAR (c->cdr), property))
  1680.     {
  1681.       c->cdr = XCDR (XCDR (c->cdr));
  1682.       return 1;
  1683.     }
  1684.     }
  1685.  
  1686.   return 0;
  1687. }
  1688.  
  1689. DEFUN ("getf", Fgetf, Sgetf, 2, 3, 0,
  1690.   "Search PROPLIST for property PROPNAME; return its value or DEFAULT.\n\
  1691. PROPLIST is a list of the sort returned by `symbol-plist'.")
  1692.      (plist, prop, defalt)           /* Cant spel in C */
  1693.      Lisp_Object plist, prop, defalt;
  1694. {
  1695.   Lisp_Object tail;
  1696.   for (tail = plist; !NILP (tail); tail = Fcdr (Fcdr (tail)))
  1697.     {
  1698.       if (EQ (prop, Fcar (tail)))
  1699.     return Fcar (Fcdr (tail));
  1700.       QUIT;
  1701.     }
  1702.   return defalt;
  1703. }
  1704.  
  1705. /* Symbol plists are directly accessible, so we need to protect against
  1706.    invalid property list structure */
  1707.  
  1708. static Lisp_Object
  1709. symbol_getprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object defalt)
  1710. {
  1711.   return Fgetf (Fsymbol_plist (sym), propname, defalt);
  1712. }
  1713.  
  1714. static void
  1715. symbol_putprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object value)
  1716. {
  1717.   Lisp_Object tail;
  1718.   Lisp_Object head = Fsymbol_plist (sym);
  1719.  
  1720.   for (tail = head; !NILP (tail); tail = Fcdr (Fcdr (tail)))
  1721.     if (EQ (propname, Fcar (tail)))
  1722.       {
  1723.     Fsetcar (Fcdr (tail), value);
  1724.     return;
  1725.       }
  1726.  
  1727.   Fsetplist (sym, Fcons (propname, Fcons (value, head)));
  1728. }
  1729.  
  1730. static int
  1731. symbol_remprop (Lisp_Object symbol, Lisp_Object propname)
  1732. {
  1733.   Lisp_Object tail;
  1734.   Lisp_Object obj;
  1735.   Lisp_Object prev;
  1736.   unsigned char changed = 0;
  1737.  
  1738.   tail = XSYMBOL (symbol)->plist;
  1739.  
  1740.   obj = Fcar (tail);
  1741.   while (!NILP (obj) && EQ (propname, obj))
  1742.     {
  1743.       changed = 1;
  1744.       tail = Fcdr (Fcdr (tail));
  1745.       obj = Fcar (tail);
  1746.     }
  1747.   XSYMBOL (symbol)->plist = tail;
  1748.   
  1749.   prev = tail;
  1750.   tail = Fcdr (Fcdr (tail));
  1751.   while (!NILP (tail))
  1752.     {
  1753.       obj = Fcar (tail);
  1754.       if (EQ (propname, obj))
  1755.     {
  1756.       changed = 1;
  1757.           Fsetcdr (Fcdr (prev), (Fcdr (Fcdr (tail))));
  1758.     }
  1759.       prev = tail;
  1760.       tail = Fcdr (Fcdr (tail));
  1761.     }
  1762.  
  1763.   return changed;
  1764. }
  1765.  
  1766. static Lisp_Object
  1767. symbol_props (Lisp_Object symbol)
  1768.           
  1769. {
  1770.   return Fcopy_sequence (Fsymbol_plist (symbol));
  1771. }
  1772.  
  1773. /* We store the string's MODIFF as the first element of the string's
  1774.    property list, but only if the string has been modified.  This is ugly
  1775.    but it reduces the memory allocated for the string in the vast
  1776.    majority of cases, where the string is never modified. */
  1777.  
  1778.  
  1779. static Lisp_Object *
  1780. string_plist_ptr (struct Lisp_String *s)
  1781. {
  1782.   return CONSP (s->plist) && INTP (XCAR (s->plist)) ?
  1783.     &XCDR (s->plist) : &s->plist;
  1784. }
  1785.  
  1786. Lisp_Object
  1787. string_getprop (struct Lisp_String *s, Lisp_Object property,
  1788.         Lisp_Object defalt)
  1789. {
  1790.   Lisp_Object value;
  1791.   if (internal_getf (*string_plist_ptr (s), property, &value))
  1792.     return value;
  1793.   return defalt;
  1794. }
  1795.  
  1796. void
  1797. string_putprop (struct Lisp_String *s, Lisp_Object property,
  1798.         Lisp_Object value)
  1799. {
  1800.   internal_putf (string_plist_ptr (s), property, value);
  1801. }
  1802.  
  1803. static int
  1804. string_remprop (struct Lisp_String *s, Lisp_Object property)
  1805. {
  1806.   return internal_remprop (string_plist_ptr (s), property);
  1807. }
  1808.  
  1809. static Lisp_Object
  1810. string_props (struct Lisp_String *s)
  1811. {
  1812.   return Fcopy_sequence (*string_plist_ptr (s));
  1813. }
  1814.  
  1815. DEFUN ("get", Fget, Sget, 2, 3, 0,
  1816.   "Return the value of OBJECT's PROPNAME property.\n\
  1817. This is the last VALUE stored with `(put OBJECT PROPNAME VALUE)'.\n\
  1818. If there is no such property, return optional third arg DEFAULT\n\
  1819. (which defaults to `nil').  OBJECT can be a symbol, face, extent,\n\
  1820. or string.  See also `put', `remprop', and `object-props'.")
  1821.      (object, propname, defalt)           /* Cant spel in C */
  1822.      Lisp_Object object, propname, defalt;
  1823. {
  1824.   Lisp_Object val;
  1825.  
  1826.   /* Various places in emacs call Fget() and expect it not to quit, so if
  1827.      the user puts a circular list in a symbol's plist, they get what they
  1828.      deserve. */
  1829.   Lisp_Object oiq = Vinhibit_quit;
  1830.   Vinhibit_quit = Qt;
  1831.   /* It's easiest to treat symbols specially because they may not
  1832.      be an lrecord */
  1833.   if (SYMBOLP (object))
  1834.     val = symbol_getprop (object, propname, defalt);
  1835.   else if (STRINGP (object))
  1836.     val = string_getprop (XSTRING (object), propname, defalt);
  1837.   else if (LRECORDP (object))
  1838.     {
  1839.       CONST struct lrecord_implementation
  1840.     *imp = XRECORD_LHEADER (object)->implementation;
  1841.       if (imp->getprop)
  1842.     {
  1843.       if (! (imp->getprop) (object, propname, &val))
  1844.         val = defalt;
  1845.     }
  1846.       else
  1847.     goto noprops;
  1848.     }
  1849.   else
  1850.     {
  1851.     noprops:
  1852.       signal_simple_error ("Object type has no properties", object);
  1853.     }
  1854.  
  1855.   Vinhibit_quit = oiq;
  1856.   return val;
  1857. }
  1858.  
  1859. DEFUN ("put", Fput, Sput, 3, 3, 0,
  1860.   "Store OBJECT's PROPNAME property with value VALUE.\n\
  1861. It can be retrieved with `(get OBJECT PROPNAME)'.  OBJECT can be a\n\
  1862. symbol, face, extent, or string.\n\
  1863. \n\
  1864. For a string, the following symbols have predefined meanings:\n\
  1865. \n\
  1866.  dup-list            List of string's extent replicas.\n\
  1867. \n\
  1868. For the predefined properties for extents, see `set-extent-property'.\n\
  1869. For the predefined properties for faces, see `set-face-property'.\n\
  1870. \n\
  1871. See also `get', `remprop', and `object-props'.")
  1872.   (object, propname, value)
  1873.      Lisp_Object object;
  1874.      Lisp_Object propname;
  1875.      Lisp_Object value;
  1876. {
  1877.   CHECK_SYMBOL (propname, 1);
  1878.   CHECK_IMPURE (object);
  1879.  
  1880.   if (SYMBOLP (object))
  1881.     symbol_putprop (object, propname, value);
  1882.   else if (STRINGP (object))
  1883.     string_putprop (XSTRING (object), propname, value);
  1884.   else if (LRECORDP (object))
  1885.     {
  1886.       CONST struct lrecord_implementation
  1887.     *imp = XRECORD_LHEADER (object)->implementation;
  1888.       if (imp->putprop)
  1889.     {
  1890.       if (! (imp->putprop) (object, propname, value))
  1891.         signal_simple_error ("Can't set property on object", propname);
  1892.     }
  1893.       else
  1894.     goto noprops;
  1895.     }
  1896.   else
  1897.     {
  1898.     noprops:
  1899.       signal_simple_error ("Object type has no settable properties", object);
  1900.     }
  1901.  
  1902.   return value;
  1903. }
  1904.  
  1905. void
  1906. pure_put (Lisp_Object sym, Lisp_Object prop, Lisp_Object val)
  1907. {
  1908.   Fput (sym, prop, Fpurecopy (val));
  1909. }
  1910.  
  1911. DEFUN ("remprop", Fremprop, Sremprop, 2, 2, 0,
  1912.   "Remove from OBJECT's property list the property PROPNAME and its\n\
  1913. value.  OBJECT can be a symbol, face, extent, or string.  Returns\n\
  1914. non-nil if the property list was actually changed (i.e. if PROPNAME\n\
  1915. was present in the property list).  See also `get', `put', and\n\
  1916. `object-props'.")
  1917.   (object, propname)
  1918.      Lisp_Object object, propname;
  1919. {
  1920.   int retval = 0;
  1921.  
  1922.   CHECK_SYMBOL (propname, 1);
  1923.   CHECK_IMPURE (object);
  1924.  
  1925.   if (SYMBOLP (object))
  1926.     retval = symbol_remprop (object, propname);
  1927.   else if (STRINGP (object))
  1928.     retval = string_remprop (XSTRING (object), propname);
  1929.   else if (LRECORDP (object))
  1930.     {
  1931.       CONST struct lrecord_implementation
  1932.     *imp = XRECORD_LHEADER (object)->implementation;
  1933.       if (imp->remprop)
  1934.     {
  1935.       retval = (imp->remprop) (object, propname);
  1936.       if (retval == -1)
  1937.         signal_simple_error ("Can't remove property from object",
  1938.                  propname);
  1939.     }
  1940.       else
  1941.     goto noprops;
  1942.     }
  1943.   else
  1944.     {
  1945.     noprops:
  1946.       signal_simple_error ("Object type has no removable properties", object);
  1947.     }
  1948.  
  1949.   return retval ? Qt : Qnil;
  1950. }
  1951.  
  1952. DEFUN ("object-props", Fobject_props, Sobject_props, 1, 1, 0,
  1953.   "Return a property list of OBJECT's props.\n\
  1954. This is a copy of OBJECT's property list, not the actual property list\n\
  1955. stored in the object; therefore, you cannot change a property on OBJECT\n\
  1956. by modifying this list.  Use `put' for that.\n\
  1957. \n\
  1958. Note that for a symbol, this function is not the same as `symbol-plist';\n\
  1959. that function returns the actual property list, whereas `object-props'\n\
  1960. returns a copy of the property list.")
  1961.      (object)
  1962.      Lisp_Object object;
  1963. {
  1964.   if (SYMBOLP (object))
  1965.     return symbol_props (object);
  1966.   else if (STRINGP (object))
  1967.     return string_props (XSTRING (object));
  1968.   else if (LRECORDP (object))
  1969.     {
  1970.       CONST struct lrecord_implementation
  1971.     *imp = XRECORD_LHEADER (object)->implementation;
  1972.       if (imp->props)
  1973.     return (imp->props) (object);
  1974.       else
  1975.     signal_simple_error ("Object type has no properties", object);
  1976.     }
  1977.  
  1978.   return Qnil;
  1979. }
  1980.  
  1981.  
  1982. int
  1983. internal_equal (Lisp_Object o1, Lisp_Object o2, int depth)
  1984. {
  1985.   if (depth > 200)
  1986.     error ("Stack overflow in equal");
  1987.  do_cdr:
  1988.   QUIT;
  1989.   if (EQ (o1, o2))
  1990.     return (1);
  1991.   /* Note that (equal 20 20.0) should be nil */
  1992.   else if (XTYPE (o1) != XTYPE (o2)) 
  1993.     return (0);
  1994.   else if (CONSP (o1))
  1995.     {
  1996.       if (!internal_equal (Fcar (o1), Fcar (o2), depth + 1))
  1997.         return (0);
  1998.       o1 = Fcdr (o1);
  1999.       o2 = Fcdr (o2);
  2000.       goto do_cdr;
  2001.     }
  2002.  
  2003. #ifndef LRECORD_VECTOR
  2004.   else if (VECTORP (o1))
  2005.     {
  2006.       int index;
  2007.       int len = vector_length (XVECTOR (o1));
  2008.       if (len != vector_length (XVECTOR (o2)))
  2009.     return (0);
  2010.       for (index = 0; index < len; index++)
  2011.     {
  2012.       Lisp_Object v1, v2;
  2013.       v1 = vector_data (XVECTOR (o1)) [index];
  2014.       v2 = vector_data (XVECTOR (o2)) [index];
  2015.       if (!internal_equal (v1, v2, depth + 1))
  2016.             return (0);
  2017.     }
  2018.       return (1);
  2019.     }
  2020. #endif /* !LRECORD_VECTOR */
  2021.   else if (STRINGP (o1))
  2022.     {
  2023.       Bytecount len = string_length (XSTRING (o1));
  2024.       if (len != string_length (XSTRING (o2)))
  2025.     return (0);
  2026.       if (memcmp (string_data (XSTRING (o1)), string_data (XSTRING (o2)), len))
  2027.     return (0);
  2028.       return (1);
  2029.     }
  2030.   else if (LRECORDP (o1))
  2031.     {
  2032.       CONST struct lrecord_implementation
  2033.     *imp1 = XRECORD_LHEADER (o1)->implementation,
  2034.     *imp2 = XRECORD_LHEADER (o2)->implementation;
  2035.       if (imp1 != imp2)
  2036.     return (0);
  2037.       else if (imp1->equal == 0)
  2038.     /* EQ-ness of the objects was noticed above */
  2039.     return (0);
  2040.       else
  2041.     return ((imp1->equal) (o1, o2, depth));
  2042.     }
  2043.  
  2044.   return (0);
  2045. }
  2046.  
  2047. DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
  2048.   "T if two Lisp objects have similar structure and contents.\n\
  2049. They must have the same data type.\n\
  2050. Conses are compared by comparing the cars and the cdrs.\n\
  2051. Vectors and strings are compared element by element.\n\
  2052. Numbers are compared by value.  Symbols must match exactly.")
  2053.   (o1, o2)
  2054.      Lisp_Object o1, o2;
  2055. {
  2056.   return ((internal_equal (o1, o2, 0)) ? Qt : Qnil);
  2057. }
  2058.  
  2059.  
  2060. DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
  2061.   "Store each element of ARRAY with ITEM.  ARRAY is a vector or string.")
  2062.   (array, item)
  2063.      Lisp_Object array, item;
  2064. {
  2065.  retry:
  2066.   if (VECTORP (array))
  2067.     {
  2068.       Lisp_Object *p;
  2069.       int size;
  2070.       int index;
  2071.       CHECK_IMPURE (array);
  2072.       size = vector_length (XVECTOR (array));
  2073.       p = vector_data (XVECTOR (array));
  2074.       for (index = 0; index < size; index++)
  2075.     p[index] = item;
  2076.     }
  2077.   else if (STRINGP (array))
  2078.     {
  2079.       Charcount size;
  2080.       Charcount index;
  2081.       Emchar charval;
  2082.       CHECK_COERCE_CHAR (item, 1);
  2083.       CHECK_IMPURE (array);
  2084.       charval = XINT (item);
  2085.       size = string_char_length (XSTRING (array));
  2086.       for (index = 0; index < size; index++)
  2087.     set_string_char (XSTRING (array), index, charval);
  2088.       bump_string_modiff (array);
  2089.     }
  2090.   else
  2091.     {
  2092.       array = wrong_type_argument (Qarrayp, array);
  2093.       goto retry;
  2094.     }
  2095.   return array;
  2096. }
  2097.  
  2098. Lisp_Object
  2099. nconc2 (Lisp_Object s1, Lisp_Object s2)
  2100. {
  2101.   Lisp_Object args[2];
  2102.   args[0] = s1;
  2103.   args[1] = s2;
  2104.   return Fnconc (2, args);
  2105. }
  2106.  
  2107. DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
  2108.   "Concatenate any number of lists by altering them.\n\
  2109. Only the last argument is not altered, and need not be a list.")
  2110.   (nargs, args)
  2111.      int nargs;
  2112.      Lisp_Object *args;
  2113. {
  2114.   int argnum;
  2115.   Lisp_Object tail, tem, val;
  2116.   struct gcpro gcpro1;
  2117.  
  2118.   /* The modus operandi in Emacs is "caller gc-protects args".
  2119.      However, nconc (particularly nconc2 ()) is called many times
  2120.      in Emacs on freshly created stuff (e.g. you see the idiom
  2121.      nconc2 (Fcopy_sequence (foo), bar) a lot).  So we help those
  2122.      callers out by protecting the args ourselves to save them
  2123.      a lot of temporary-variable grief. */
  2124.  
  2125.   GCPRO1 (args[0]);
  2126.   gcpro1.nvars = nargs;
  2127.      
  2128.   val = Qnil;
  2129.  
  2130.   for (argnum = 0; argnum < nargs; argnum++)
  2131.     {
  2132.       tem = args[argnum];
  2133.       if (NILP (tem)) continue;
  2134.  
  2135.       if (NILP (val))
  2136.     val = tem;
  2137.  
  2138.       if (argnum + 1 == nargs) break;
  2139.  
  2140.       if (!CONSP (tem))
  2141.     tem = wrong_type_argument (Qlistp, tem);
  2142.  
  2143.       while (CONSP (tem))
  2144.     {
  2145.       tail = tem;
  2146.       tem = Fcdr (tail);
  2147.       QUIT;
  2148.     }
  2149.  
  2150.       tem = args[argnum + 1];
  2151.       Fsetcdr (tail, tem);
  2152.       if (NILP (tem))
  2153.     args[argnum + 1] = tail;
  2154.     }
  2155.  
  2156.   RETURN_UNGCPRO (val);
  2157. }
  2158.  
  2159.  
  2160. /* This is the guts of all mapping functions.
  2161.  Apply fn to each element of seq, one by one,
  2162.  storing the results into elements of vals, a C vector of Lisp_Objects.
  2163.  leni is the length of vals, which should also be the length of seq. */
  2164.  
  2165. static void
  2166. mapcar1 (int leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
  2167. {
  2168.   Lisp_Object tail;
  2169.   Lisp_Object dummy;
  2170.   int i;
  2171.   struct gcpro gcpro1, gcpro2, gcpro3;
  2172.  
  2173.   /* Don't let vals contain any garbage when GC happens.  */
  2174.   for (i = 0; i < leni; i++)
  2175.     vals[i] = Qnil;
  2176.  
  2177.   GCPRO3 (dummy, fn, seq);
  2178.   gcpro1.var = vals;
  2179.   gcpro1.nvars = leni;
  2180.   /* We need not explicitly protect `tail' because it is used only on lists, and
  2181.     1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
  2182.  
  2183.   if (VECTORP (seq))
  2184.     {
  2185.       for (i = 0; i < leni; i++)
  2186.     {
  2187.       dummy = vector_data (XVECTOR (seq))[i];
  2188.       vals[i] = call1 (fn, dummy);
  2189.     }
  2190.     }
  2191.   else if (STRINGP (seq))
  2192.     {
  2193.       for (i = 0; i < leni; i++)
  2194.     {
  2195.       vals[i] = call1 (fn, make_number (string_char (XSTRING (seq), i)));
  2196.     }
  2197.     }
  2198.   else   /* Must be a list, since Flength did not get an error */
  2199.     {
  2200.       tail = seq;
  2201.       for (i = 0; i < leni; i++)
  2202.     {
  2203.       vals[i] = call1 (fn, Fcar (tail));
  2204.       tail = Fcdr (tail);
  2205.     }
  2206.     }
  2207.  
  2208.   UNGCPRO;
  2209. }
  2210.  
  2211. DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
  2212.   "Apply FN to each element of SEQ, and concat the results as strings.\n\
  2213. In between each pair of results, stick in SEP.\n\
  2214. Thus, \" \" as SEP results in spaces between the values returned by FN.")
  2215.   (fn, seq, sep)
  2216.      Lisp_Object fn, seq, sep;
  2217. {
  2218.   Lisp_Object len;
  2219.   int leni;
  2220.   int nargs;
  2221.   Lisp_Object *args;
  2222.   int i;
  2223.   struct gcpro gcpro1;
  2224.  
  2225.   len = Flength (seq);
  2226.   leni = XINT (len);
  2227.   nargs = leni + leni - 1;
  2228.   if (nargs < 0) return build_string ("");
  2229.  
  2230.   args = (Lisp_Object *) alloca (nargs * sizeof (Lisp_Object));
  2231.  
  2232.   GCPRO1 (sep);
  2233.   mapcar1 (leni, args, fn, seq);
  2234.   UNGCPRO;
  2235.  
  2236.   for (i = leni - 1; i >= 0; i--)
  2237.     args[i + i] = args[i];
  2238.       
  2239.   for (i = 1; i < nargs; i += 2)
  2240.     args[i] = sep;
  2241.  
  2242.   return Fconcat (nargs, args);
  2243. }
  2244.  
  2245. DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
  2246.   "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
  2247. The result is a list just as long as SEQUENCE.\n\
  2248. SEQUENCE may be a list, a vector or a string.")
  2249.   (fn, seq)
  2250.      Lisp_Object fn, seq;
  2251. {
  2252.   Lisp_Object len;
  2253.   int leni;
  2254.   Lisp_Object *args;
  2255.  
  2256.   len = Flength (seq);
  2257.   leni = XINT (len);
  2258.   args = (Lisp_Object *) alloca (leni * sizeof (Lisp_Object));
  2259.  
  2260.   mapcar1 (leni, args, fn, seq);
  2261.  
  2262.   return Flist (leni, args);
  2263. }
  2264.  
  2265.  
  2266. /* #### this function doesn't belong in this file! */
  2267.  
  2268. DEFUN ("load-average", Fload_average, Sload_average, 0, 0, 0,
  2269.   "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
  2270. Each of the three load averages is multiplied by 100,\n\
  2271. then converted to integer.\n\
  2272. \n\
  2273. If the 5-minute or 15-minute load averages are not available, return a\n\
  2274. shortened list, containing only those averages which are available.\n\
  2275. \n\
  2276. On most systems, this won't work unless the emacs executable is installed\n\
  2277. as setgid kmem (assuming that /dev/kmem is in the group kmem).")
  2278.   ()
  2279. {
  2280.   double load_ave[10]; /* hey, just in case */
  2281.   int loads = getloadavg (load_ave, 3);
  2282.   Lisp_Object ret;
  2283.  
  2284.   if (loads == -2)
  2285.     error ("load-average not implemented for this operating system.");
  2286.   else if (loads < 0)
  2287.     error ("could not get load-average; check permissions.");
  2288.  
  2289.   ret = Qnil;
  2290.   while (loads > 0)
  2291.     ret = Fcons (make_number ((int) (load_ave[--loads] * 100.0)), ret);
  2292.  
  2293.   return ret;
  2294. }
  2295.  
  2296.  
  2297. Lisp_Object Vfeatures;
  2298.  
  2299. DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 1, 0,
  2300.   "Return t if FEATURE is present in this Emacs.\n\
  2301. Use this to conditionalize execution of lisp code based on the presence or\n\
  2302. absence of emacs or environment extensions.\n\
  2303. Use `provide' to declare that a feature is available.\n\
  2304. This function looks at the value of the variable `features'.")
  2305.      (feature)
  2306.      Lisp_Object feature;
  2307. {
  2308.   Lisp_Object tem;
  2309.   CHECK_SYMBOL (feature, 0);
  2310.   tem = Fmemq (feature, Vfeatures);
  2311.   return (NILP (tem)) ? Qnil : Qt;
  2312. }
  2313.  
  2314. DEFUN ("provide", Fprovide, Sprovide, 1, 1, 0,
  2315.   "Announce that FEATURE is a feature of the current Emacs.")
  2316.      (feature)
  2317.      Lisp_Object feature;
  2318. {
  2319.   Lisp_Object tem;
  2320.   CHECK_SYMBOL (feature, 0);
  2321.   if (!NILP (Vautoload_queue))
  2322.     Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
  2323.   tem = Fmemq (feature, Vfeatures);
  2324.   if (NILP (tem))
  2325.     Vfeatures = Fcons (feature, Vfeatures);
  2326.   LOADHIST_ATTACH (Fcons (Qprovide, feature));
  2327.   return feature;
  2328. }
  2329.  
  2330. DEFUN ("require", Frequire, Srequire, 1, 2, 0,
  2331.   "If feature FEATURE is not loaded, load it from FILENAME.\n\
  2332. If FEATURE is not a member of the list `features', then the feature\n\
  2333. is not loaded; so load the file FILENAME.\n\
  2334. If FILENAME is omitted, the printname of FEATURE is used as the file name.")
  2335.      (feature, file_name)
  2336.      Lisp_Object feature, file_name;
  2337. {
  2338.   Lisp_Object tem;
  2339.   CHECK_SYMBOL (feature, 0);
  2340.   tem = Fmemq (feature, Vfeatures);
  2341.   LOADHIST_ATTACH (Fcons (Qrequire, feature));
  2342.   if (!NILP (tem))
  2343.     return (feature);
  2344.   else
  2345.     {
  2346.       int speccount = specpdl_depth ();
  2347.  
  2348.       /* Value saved here is to be restored into Vautoload_queue */
  2349.       record_unwind_protect (un_autoload, Vautoload_queue);
  2350.       Vautoload_queue = Qt;
  2351.  
  2352.       call4 (Qload, NILP (file_name) ? Fsymbol_name (feature) : file_name,
  2353.          Qnil, Qt, Qnil);
  2354.  
  2355.       tem = Fmemq (feature, Vfeatures);
  2356.       if (NILP (tem))
  2357.     error ("Required feature %s was not provided",
  2358.            string_data (XSYMBOL (feature)->name));
  2359.  
  2360.       /* Once loading finishes, don't undo it.  */
  2361.       Vautoload_queue = Qt;
  2362.       return (unbind_to (speccount, feature));
  2363.     }
  2364. }
  2365.  
  2366.  
  2367. Lisp_Object Qyes_or_no_p;
  2368.  
  2369. void
  2370. syms_of_fns (void)
  2371. {
  2372.   defsymbol (&Qstring_lessp, "string-lessp");
  2373.   defsymbol (&Qidentity, "identity");
  2374.   defsymbol (&Qyes_or_no_p, "yes-or-no-p");
  2375.  
  2376.   defsubr (&Sidentity);
  2377.   defsubr (&Srandom);
  2378.   defsubr (&Slength);
  2379.   defsubr (&Sstring_equal);
  2380.   defsubr (&Sstring_lessp);
  2381.   defsubr (&Sstring_modified_tick);
  2382.   defsubr (&Sappend);
  2383.   defsubr (&Sconcat);
  2384.   defsubr (&Svconcat);
  2385.   defsubr (&Scopy_sequence);
  2386.   defsubr (&Scopy_alist);
  2387.   defsubr (&Scopy_tree);
  2388.   defsubr (&Ssubstring);
  2389.   defsubr (&Snthcdr);
  2390.   defsubr (&Snth);
  2391.   defsubr (&Selt);
  2392.   defsubr (&Smember);
  2393.   defsubr (&Smemq);
  2394.   defsubr (&Sassoc);
  2395.   defsubr (&Sassq);
  2396.   defsubr (&Srassoc);
  2397.   defsubr (&Srassq);
  2398.   defsubr (&Sdelete);
  2399.   defsubr (&Sdelq);
  2400.   defsubr (&Sremassoc);
  2401.   defsubr (&Sremassq);
  2402.   defsubr (&Sremrassoc);
  2403.   defsubr (&Sremrassq);
  2404.   defsubr (&Snreverse);
  2405.   defsubr (&Sreverse);
  2406.   defsubr (&Ssort);
  2407.   defsubr (&Splists_eq);
  2408.   defsubr (&Splists_equal);
  2409.   defsubr (&Sgetf);
  2410.   defsubr (&Sget);
  2411.   defsubr (&Sput);
  2412.   defsubr (&Sremprop);
  2413.   defsubr (&Sobject_props);
  2414.   defsubr (&Sequal);
  2415.   defsubr (&Sfillarray);
  2416.   defsubr (&Snconc);
  2417.   defsubr (&Smapcar);
  2418.   defsubr (&Smapconcat);
  2419.   defsubr (&Sload_average);
  2420.   defsubr (&Sfeaturep);
  2421.   defsubr (&Srequire);
  2422.   defsubr (&Sprovide);
  2423. }
  2424.  
  2425. void
  2426. init_provide_once (void)
  2427. {
  2428.   DEFVAR_LISP ("features", &Vfeatures,
  2429.     "A list of symbols which are the features of the executing emacs.\n\
  2430. Used by `featurep' and `require', and altered by `provide'.");
  2431.   Vfeatures = Qnil;
  2432. }
  2433.